Celestin Apprentice 7/Apprentice-Release7.iso/Source Code/C/Applications/Moscow ML 1.42/src/compiler/Units.sml

Text File | 1997-08-18 | 13.3 KB | 506 lines | [TEXT/R*ch]

open Misc BasicIO Nonstdio Fnlib Config Mixture Const Globals Location;

(* Compiled signatures *)

type CSig =
{
  uName:       string,
  uConBasis:   (string, ConStatus) Hasht.t,
  uVarEnv:     (string, TypeScheme) Hasht.t,
  uTyEnv:      (string, TyName) Hasht.t,
  uDatatypes:  (int, ConEnv) Hasht.t,
  uStamp:      SigStamp option ref,
                    (* present, if this signature comes from a .ui file *)
  uMentions:   (string, SigStamp) Hasht.t
};

fun conBasisOfSig   (cu : CSig) = #uConBasis cu
and varEnvOfSig     (cu : CSig) = #uVarEnv cu
and tyEnvOfSig      (cu : CSig) = #uTyEnv cu
;

(* The table of unit signatures already loaded in memory *)

type SigTable = (string, CSig) Hasht.t;

fun mkSigTable() = (Hasht.new 37 : SigTable);
val dummySigTable = (Hasht.new 0 : SigTable);

val pervSigTable = (Hasht.new 7 : SigTable);

val currentSigTable = ref dummySigTable;

fun newSig nm : CSig =
{
  uName = nm,
  uConBasis   = Hasht.new 13,
  uVarEnv     = Hasht.new 17,
  uTyEnv      = Hasht.new 7,
  uDatatypes  = Hasht.new 7,
  uMentions   = Hasht.new 13,
  uStamp      = ref NONE
};

(* Current signature *)

val dummySig = newSig "";

val currentSig = ref dummySig;

val dummyInfixBasis = (Hasht.new 0 : (string, InfixStatus) Hasht.t);

val currentInfixBasis = ref dummyInfixBasis;

val currentTypeStamp = ref 0;
val currentExcStamp = ref 0;
val currentValStamp = ref 0;
val currentDatatypeStamp = ref 0;

val dummyRenEnv = (Hasht.new 0 : (string, int) Hasht.t);

val currentRenEnv = ref dummyRenEnv;
val hasSpecifiedSignature = ref false;

(* To load a signature from a file *)

fun readSig name =
  let val filename = find_in_path (name ^ ".ui")
      val is = open_in_bin filename
  in
    let
      val sigStamp = input(is, 22)
      val () = if size sigStamp < 22 then raise Fail "sigStamp" else ()
      val cu = (input_value is : CSig)
      val {uStamp, uName, ...} = cu
    in
      close_in is;
      uStamp := SOME sigStamp;
      if name <> uName then (
        msgIBlock 0;
        errPrompt "File "; msgString filename;
        msgString " contains the signature of unit ";
        msgString uName; msgEOL();
        errPrompt "instead of the signature of unit ";
        msgString name; msgEOL();
        msgEBlock();
        raise Toplevel)
      else ();
      cu
    end
    handle Fail _ =>
      (close_in is;
       msgIBlock 0;
       errPrompt "Corrupted compiled signature file: ";
       msgString filename; msgEOL();
       msgEBlock();
       raise Toplevel)
  end;

(* To find a pervasive signature by its name *)

fun findPervSig uname =
  Hasht.find pervSigTable uname
  handle Subscript =>
    fatalError "findPervSig"
;

(* To find a signature by its name *)

fun findSig loc uname =
  Hasht.find pervSigTable uname
  handle Subscript =>
    (Hasht.find (!currentSigTable) uname
     handle Subscript =>
       (if #uName(!currentSig) = "Top" then
          (ignore(Hasht.find (!watchDog) uname)
           handle Subscript =>
             errorMsg loc ("Cannot access unit " ^ uname ^
                           " before it has been loaded."))
        else ();
        let val cu =
          readSig uname
            handle Fail msg => errorMsg loc msg
        in
          Hasht.insert (!currentSigTable) uname cu; cu
        end))
;

(* --- The current state of the compiler --- *)

val pervasiveInfixTable =
  (Hasht.new 7 : (string, InfixStatus) Hasht.t);

val pervasiveInfixBasis = mk1TopEnv pervasiveInfixTable;
val pervasiveConBasis   = ref (NILenv : (string, ConStatus) Env);
val pervasiveStaticVE   = ref (NILenv : (string, TypeScheme) Env);
val pervasiveStaticTE   = ref (NILenv : (string, TyName) Env);

fun initPervasiveEnvironments() =
(
  pervasiveConBasis   := NILenv;
  pervasiveStaticVE   := NILenv;
  pervasiveStaticTE   := NILenv;
  List.app
    (fn uname =>
       let val cu = findPervSig uname in
         pervasiveConBasis :=
             bindTopInEnv (!pervasiveConBasis) (#uConBasis cu);
         pervasiveStaticVE :=
             bindTopInEnv (!pervasiveStaticVE) (#uVarEnv cu);
         pervasiveStaticTE :=
             bindTopInEnv (!pervasiveStaticTE) (#uTyEnv cu)
       end)
    pervasiveOpenedUnits
);

(* Find and mention a signature *)

fun findAndMentionSig loc uname =
  let val cu = findSig loc uname in
    (case !(#uStamp cu) of
         NONE => ()
       | SOME stamp =>
           let val mentions = #uMentions (!currentSig) in
             ignore(Hasht.find mentions uname)
             handle Subscript => Hasht.insert mentions uname stamp
           end);
    cu
  end;

val initialConBasis   = ref (NILenv : (string, ConStatus) Env);
val initialStaticVE   = ref (NILenv : (string, TypeScheme) Env);
val initialStaticTE   = ref (NILenv : (string, TyName) Env);

fun initInitialEnvironments() =
(
  initialConBasis   := !pervasiveConBasis;
  initialStaticVE   := !pervasiveStaticVE;
  initialStaticTE   := !pervasiveStaticTE;
  List.app
    (fn uname =>
       let val cu = findAndMentionSig nilLocation uname in
         initialConBasis := bindTopInEnv (!initialConBasis) (#uConBasis cu);
         initialStaticVE := bindTopInEnv (!initialStaticVE) (#uVarEnv cu);
         initialStaticTE := bindTopInEnv (!initialStaticTE) (#uTyEnv cu)
       end)
    (!preopenedPreloadedUnits)
);

(* To put aside the current toplevel unit while compiling another unit. *)

fun protectCurrentUnit fct =
  let
    val saved_currentSigTable = !currentSigTable
    val saved_currentSig = !currentSig
    val saved_currentInfixBasis = !currentInfixBasis
    val saved_currentTypeStamp = !currentTypeStamp
    val saved_currentExcStamp = !currentExcStamp
    val saved_currentValStamp = !currentValStamp
    val saved_currentDatatypeStamp = !currentDatatypeStamp
    val saved_currentRenEnv = !currentRenEnv
    val saved_initialConBasis = !initialConBasis
    val saved_initialStaticVE = !initialStaticVE
    val saved_initialStaticTE = !initialStaticTE
  in
    (
    fct();
    currentSigTable := saved_currentSigTable;
    currentSig := saved_currentSig;
    currentInfixBasis := saved_currentInfixBasis;
    currentTypeStamp := saved_currentTypeStamp;
    currentExcStamp := saved_currentExcStamp;
    currentValStamp := saved_currentValStamp;
    currentDatatypeStamp := saved_currentDatatypeStamp;
    currentRenEnv := saved_currentRenEnv;
    initialConBasis := saved_initialConBasis;
    initialStaticVE := saved_initialStaticVE;
    initialStaticTE := saved_initialStaticTE
    )
    handle x =>
      (
      currentSigTable := saved_currentSigTable;
      currentSig := saved_currentSig;
      currentInfixBasis := saved_currentInfixBasis;
      currentTypeStamp := saved_currentTypeStamp;
      currentExcStamp := saved_currentExcStamp;
      currentValStamp := saved_currentValStamp;
      currentDatatypeStamp := saved_currentDatatypeStamp;
      currentRenEnv := saved_currentRenEnv;
      initialConBasis := saved_initialConBasis;
      initialStaticVE := saved_initialStaticVE;
      initialStaticTE := saved_initialStaticTE;
      raise x
      )
  end;

fun currentUnitName() =
  #uName(!currentSig)
;

fun mkGlobalName id =
  { qual = #uName(!currentSig), id = id }
;

fun mkGlobalInfo id info =
  { qualid = mkGlobalName id, info = info }
;

fun mkUniqueGlobalName (id, stamp) =
  ({ qual = #uName(!currentSig), id = id }, stamp)
;

fun newTypeStamp() =
(
  incr currentTypeStamp;
  !currentTypeStamp
);

fun newExcStamp() =
(
  incr currentExcStamp;
  !currentExcStamp
);

fun newValStamp() =
(
  incr currentValStamp;
  !currentValStamp
);

fun newDatatypeStamp() =
(
  incr currentDatatypeStamp;
  !currentDatatypeStamp
);

(* Additions to the unit being compiled *)

fun add_global_info sel_fct id info =
  let val tbl = sel_fct (!currentSig) in
    Hasht.insert tbl id info
  end
;

fun add_InfixBasis id info =
  Hasht.insert (!currentInfixBasis) id info
;

val add_ConBasis = add_global_info conBasisOfSig
and add_VarEnv   = add_global_info varEnvOfSig
and add_TyEnv    = add_global_info tyEnvOfSig
;

(* Additions to the unit being compiled *)
(* without redefining names that are already bound! *)

fun extend_ConBasis id info =
  let val tbl = conBasisOfSig (!currentSig) in
    (ignore (Hasht.find tbl id);
     msgIBlock 0;
     errPrompt "Value identifier ";
     msgString id; msgString " cannot be redefined in a signature.";
     msgEOL();
     msgEBlock();
     raise Toplevel)
    handle Subscript =>
      Hasht.insert tbl id info
  end;

fun extend_TyEnv id info =
  let val tbl = tyEnvOfSig (!currentSig) in
    (ignore (Hasht.find tbl id);
     msgIBlock 0;
     errPrompt "Type constructor ";
     msgString id; msgString " cannot be redefined in a signature.";
     msgEOL();
     msgEBlock();
     raise Toplevel)
    handle Subscript =>
      Hasht.insert tbl id info
  end;

(* Find the information for a reference to a qualified identifier. *)

fun findInfo sel_fct env loc q =
  let val {qual, id} = q in
    if qual = "" then
      lookupEnv env id
    else if qual = #uName(!currentSig) then
      (msgIBlock 0;
       errLocation loc;
       errPrompt "Qualifier cannot refer to the current unit: ";
       printQualId q; msgEOL();
       msgEBlock();
       raise Toplevel)
    else
      Hasht.find (sel_fct (findAndMentionSig loc qual)) id
  end;

(* Find constructors for a datatype. *)

fun findConstructors (sign : CSig) stamp =
  Hasht.find (#uDatatypes sign) stamp
  handle Subscript => fatalError "findConstructors"
;

fun setConstructors (sign : CSig) stamp CE =
  Hasht.insert (#uDatatypes sign) stamp CE
;

fun registerConstructors CE =
  let val stamp = newDatatypeStamp() in
    setConstructors (!currentSig) stamp CE;
    stamp
  end;

(* We have to compare the whole qualids, because in exported *)
(* TyNames all stamps are reset to 0. Therefore, different   *)
(* exported TyNames may have equal stamps. *)

fun isEqTN (tn1 : TyName) (tn2 : TyName) =
  #qualid tn1 = #qualid tn2 andalso
  #tnStamp (!(#info tn1)) = #tnStamp (!(#info tn2))
;

fun updateCurrentInfixBasis iBas =
  traverseEnv add_InfixBasis (revEnv iBas)
;

fun updateCurrentConBasis cBas =
  traverseEnv add_ConBasis (revEnv cBas)
;

fun extendCurrentConBasis cBas =
  traverseEnv extend_ConBasis (revEnv cBas)
;

fun updateCurrentStaticVE VE =
  traverseEnv add_VarEnv (revEnv VE)
;

fun updateCurrentStaticTE TE =
  traverseEnv add_TyEnv (revEnv TE)
;

fun extendCurrentStaticTE TE =
  traverseEnv extend_TyEnv (revEnv TE)
;

fun mkGlobalInfixBasis() =
  bindTopInEnv pervasiveInfixBasis (!currentInfixBasis)
;

fun mkGlobalConBasis() =
  bindTopInEnv (!initialConBasis) (#uConBasis (!currentSig))
;

fun mkGlobalVE() =
  bindTopInEnv (!initialStaticVE) (#uVarEnv (!currentSig))
;

fun mkGlobalTE() =
  bindTopInEnv (!initialStaticTE) (#uTyEnv (!currentSig))
;

fun execToplevelOpen loc uname =
  let val cu = findAndMentionSig loc uname in
    updateCurrentConBasis (mk1TopEnv (#uConBasis cu));
    updateCurrentStaticVE (mk1TopEnv (#uVarEnv cu));
    updateCurrentStaticTE (mk1TopEnv (#uTyEnv cu))
  end;

fun printHiddenId id =
  (msgString "?{"; msgString id; msgString "}")
;

fun printVQ q =
  let val {qual, id} = q
      fun printHidden() =
            if qual <> #uName(!currentSig) then
              (msgString qual; msgString ".";
               msgString id)
            else
              printHiddenId id
  in
    (if #qual(#qualid (lookupEnv (mkGlobalConBasis()) id)) = qual then
        msgString id
      else
        printHidden())
    handle Subscript =>
      printHidden()
  end;

fun printTQ tn =
  let val {qualid, info} = tn
      val {qual, id} = qualid
      fun printHidden() =
            if qual <> #uName(!currentSig) then
              (msgString qual; msgString ".";
               if #tnStamp(!info) <> 0 then
                 printHiddenId id
               else
                 msgString id)
            else
              printHiddenId id
  in
    let val tn0 = lookupEnv (mkGlobalTE()) id in
      if isEqTN tn tn0 then msgString id else printHidden()
    end
    handle Subscript =>
      printHidden()
  end;

fun mkInfixBasis() = (Hasht.new 13 : (string, InfixStatus) Hasht.t);
fun mkRenEnv() = (Hasht.new 113 : (string, int) Hasht.t);

fun startCompilingUnit name =
(
  currentSigTable := mkSigTable();
  currentSig := newSig name;
  currentInfixBasis := mkInfixBasis();
  currentTypeStamp := 0;
  currentExcStamp := 0;
  currentValStamp := 0;
  currentDatatypeStamp := 0;
  currentRenEnv := mkRenEnv()
);

fun rectifyConBasis cBas =
  let
    val excRen = ref( [] : (QualifiedIdent * (QualifiedIdent * int)) list )
  in
    Hasht.apply (fn id => fn (status : ConStatus) =>
        case #info status of
            EXNname ei =>
              (case #exconTag(!ei) of
                   NONE => fatalError "rectifyConBasis"
                 | SOME (name, stamp) =>
                     if #qual(#qualid status) = #uName(!currentSig) then
                       excRen := (#qualid status, (name, stamp)) :: !excRen
                     else ())
          | _ => ())
      cBas;
    (!excRen)
  end;

fun rectifyCurrentTyEnv() =
  let val tyEnv = #uTyEnv (!currentSig) in
    Hasht.apply (fn _ => fn tn =>
        let val {info, ...} = tn in
          if #tnStamp(!info) <> 0 then (setTnStamp info 0) else ()
        end)
      tyEnv
  end;

fun rectifySignature() =
  let val () = rectifyCurrentTyEnv()
      val excRenList = rectifyConBasis (#uConBasis(!currentSig))
      val valRenList =
        foldEnv (fn id => fn stamp => fn acc => (id,stamp)::acc)
                [] (mk1TopEnv (!currentRenEnv))
  in
    currentRenEnv := dummyRenEnv;
    (excRenList, valRenList)
  end;